home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / print / ppdec.sml < prev    next >
Encoding:
Text File  |  1993-02-05  |  7.1 KB  |  229 lines
  1. (* Copyright 1989 by AT&T Bell Laboratories *)
  2. (* ppdec.sml *)
  3.  
  4. structure PPDec : PPDEC =
  5. struct 
  6.  
  7. open Types Variables Modules Fixity Absyn
  8.      PrettyPrint PPUtil PPType PPVal PPBasics Access
  9.  
  10. type object = System.Unsafe.object
  11.  
  12. val signatures = System.Print.signatures
  13. val printDepth = System.Print.printDepth
  14.  
  15. fun pplist_nl ppstrm pr =
  16.    let fun pp [] = ()
  17.          | pp [el] = pr el
  18.          | pp (el::rst) = (pr el; add_newline ppstrm; pp rst)
  19.    in  pp
  20.    end;
  21.  
  22. fun C f x y = f y x;
  23.  
  24. fun ppDec env ppstrm dec lookup =
  25.     let val dec = (* pruneDec *) dec
  26.         fun ppVb (VB{pat,...}) =
  27.         let fun ppBind(pat) =
  28.             case pat
  29.               of VARpat(VALvar{name=[n],access,typ=ref ty}) => 
  30.                (begin_block ppstrm CONSISTENT 0;
  31.                 begin_block ppstrm INCONSISTENT 2;
  32.                 add_string ppstrm "val "; 
  33.                 ppSym ppstrm n; 
  34.                 add_string ppstrm " =";
  35.                 add_break ppstrm (1,0);
  36.                 case access
  37.                   of PATH[lv] => ppVal env ppstrm 
  38.                                                    (lookup lv, ty, !printDepth)
  39.                    | INLINE _ => add_string ppstrm "<primop>"
  40.                    | _ => ErrorMsg.impossible
  41.                         "ppDec.ppVb.ppBind.VARpat";
  42.                 add_break ppstrm (1,0);
  43.                 add_string ppstrm ": "; 
  44.                 ppType env ppstrm ty;
  45.                 end_block ppstrm;
  46.                 add_newline ppstrm;
  47.                 end_block ppstrm)
  48.                | RECORDpat{pats=ref pl,...} => app ppBind pl
  49.                | VECTORpat(pats,_) => app ppBind pats
  50.                | APPpat(_,_,pat) => ppBind pat
  51.                | CONSTRAINTpat(pat,_) => ppBind pat
  52.                | LAYEREDpat(pat1,pat2) => (ppBind pat1; ppBind pat2)
  53.                | _ => ()
  54.          in ppBind pat
  55.         end
  56.  
  57.     and ppRvb (RVB{var=VALvar{name=[n],access=PATH[lv],typ},...}) = 
  58.         (begin_block ppstrm CONSISTENT 0;
  59.          begin_block ppstrm INCONSISTENT 2;
  60.          add_string ppstrm "val "; 
  61.          ppSym ppstrm n; 
  62.          add_string ppstrm " =";
  63.          add_break ppstrm (1,0);
  64.                                 (* only prints functions! *)
  65.          ppVal env ppstrm (lookup lv, !typ, !printDepth);
  66.          add_break ppstrm (1,0);
  67.          add_string ppstrm ": "; 
  68.          ppType env ppstrm (!typ); 
  69.          end_block ppstrm;
  70.          add_newline ppstrm;
  71.          end_block ppstrm)
  72.  
  73.     and ppTb(TB{tyc=DEFtyc{path=name::_,tyfun=TYFUN{arity,...},...},def}) =
  74.         (begin_block ppstrm CONSISTENT 0;
  75.          begin_block ppstrm INCONSISTENT 2;
  76.          add_string ppstrm "type "; 
  77.          ppFormals ppstrm arity; 
  78.          add_break ppstrm (1,0);
  79.          ppSym ppstrm name; 
  80.          add_string ppstrm " ="; 
  81.          add_break ppstrm (1,0);
  82.          ppType env ppstrm def;
  83.          end_block ppstrm;
  84.              add_newline ppstrm;
  85.          end_block ppstrm)
  86.  
  87.     and ppAbsTyc(GENtyc{path=name::_, arity,eq,kind=ref(ABStyc _), ...}) =
  88.         (begin_block ppstrm CONSISTENT 0;
  89.          begin_block ppstrm INCONSISTENT 2;
  90.          add_string ppstrm(if (!eq=YES) then "eqtype" else "type"); 
  91.          ppFormals ppstrm arity; 
  92.          add_break ppstrm (1,0);
  93.          ppSym ppstrm name; 
  94.          end_block ppstrm;
  95.              add_newline ppstrm;
  96.          end_block ppstrm)
  97.  
  98.     and ppDataTyc(GENtyc{path=name::_,arity,kind=ref(DATAtyc dcons),...}) =
  99.         (begin_block ppstrm CONSISTENT 0;
  100.          begin_block ppstrm CONSISTENT 0;
  101.          add_string ppstrm "datatype ";
  102.          ppFormals ppstrm arity;
  103.          add_string ppstrm " ";
  104.          ppSym ppstrm name; 
  105.              add_break ppstrm (500,2); (* force a linebreak with indent 2 *)
  106.          begin_block ppstrm CONSISTENT 0;
  107.          pplist_nl ppstrm
  108.            (fn DATACON{name,typ,...} => 
  109.              (begin_block ppstrm INCONSISTENT 0;
  110.               add_string ppstrm "con "; 
  111.               ppSym ppstrm name; 
  112.               add_break ppstrm (1,0); 
  113.               add_string ppstrm ": "; 
  114.               ppType env ppstrm typ;
  115.               end_block ppstrm))
  116.          dcons;
  117.          end_block ppstrm;
  118.          end_block ppstrm;
  119.          add_newline ppstrm;
  120.          end_block ppstrm)
  121.  
  122.     and ppEb(EBgen{exn=DATACON{name,...},etype,...}) =
  123.           (begin_block ppstrm CONSISTENT 0;
  124.            begin_block ppstrm INCONSISTENT 2;
  125.            add_string ppstrm "exception "; 
  126.            ppSym ppstrm name;
  127.            case etype
  128.          of NONE => ()
  129.           | SOME ty' => 
  130.                    (add_string ppstrm " of"; 
  131.                 add_break ppstrm (1,0);
  132.                 ppType env ppstrm ty');
  133.            end_block ppstrm;
  134.             add_newline ppstrm;
  135.            end_block ppstrm)
  136.       | ppEb(EBdef{exn=DATACON{name,...},edef=DATACON{name=dname,...}}) =
  137.           (begin_block ppstrm CONSISTENT 0;
  138.            begin_block ppstrm INCONSISTENT 2;
  139.            add_string ppstrm "exception "; 
  140.            ppSym ppstrm name;
  141.            add_string ppstrm " ="; 
  142.            add_break ppstrm (1,0);
  143.            ppSym ppstrm dname;
  144.            end_block ppstrm;
  145.             add_newline ppstrm;
  146.            end_block ppstrm)
  147.  
  148.     and ppStrb isAbs (STRB{strvar,...}) =    (* isAbs strvar *)
  149.         (begin_block ppstrm CONSISTENT 0;
  150.          PPBasics.ppStructureVar ppstrm (env,strvar,!signatures);
  151.          add_newline ppstrm;
  152.          end_block ppstrm)
  153.  
  154.     and ppFctb(FCTB{fctvar,...}) = 
  155.         (begin_block ppstrm CONSISTENT 0;
  156.          PPBasics.ppFunctorVar ppstrm (env,fctvar,!signatures);
  157.          add_newline ppstrm;
  158.          end_block ppstrm)
  159.  
  160.         and ppSigb s = 
  161.         (begin_block ppstrm CONSISTENT 0;
  162.          PPBasics.ppSignatureVar ppstrm (env,s,!signatures);
  163.          add_newline ppstrm;
  164.          end_block ppstrm)
  165.  
  166.         and ppFsigb s = 
  167.         (begin_block ppstrm CONSISTENT 0;
  168.          PPBasics.ppFunsigVar ppstrm (env,s,!signatures);
  169.          add_newline ppstrm;
  170.          end_block ppstrm)
  171.  
  172.     and ppFixity{fixity,ops} =
  173.         (begin_block ppstrm CONSISTENT 0;
  174.          begin_block ppstrm CONSISTENT 0;
  175.          add_string ppstrm (Fixity.fixityToString fixity);
  176.          PPUtil.ppSequence ppstrm {sep=C PrettyPrint.add_break (1,0),
  177.                            pr=PPUtil.ppSym,
  178.                            style=INCONSISTENT}
  179.                            ops;
  180.          end_block ppstrm;
  181.          add_newline ppstrm;               
  182.          end_block ppstrm)
  183.  
  184.     and ppOpen(strvl) =  
  185.         (begin_block ppstrm CONSISTENT 0;
  186.          begin_block ppstrm CONSISTENT 0;
  187.          add_string ppstrm "open ";
  188.          ppSequence ppstrm {sep=C PrettyPrint.add_break (1,0),
  189.             pr=(fn ppstrm => fn STRvar{name,...}
  190.                             => ppSym ppstrm name),
  191.             style=INCONSISTENT}
  192.                     strvl;
  193.          end_block ppstrm;
  194.          add_newline ppstrm;               
  195.          end_block ppstrm)
  196.  
  197.     and ppDec0 dec =
  198.         case (resetPPType(); dec)
  199.           of VALdec vbs => app ppVb vbs
  200.            | VALRECdec rvbs => app ppRvb rvbs
  201.            | TYPEdec tbs => app ppTb tbs
  202.            | DATATYPEdec{datatycs,withtycs} =>
  203.            (app ppDataTyc datatycs; 
  204.             app ppTb withtycs)
  205.            | ABSTYPEdec{abstycs,withtycs,body} =>
  206.            (app ppAbsTyc abstycs;
  207.             app ppTb withtycs;
  208.             ppDec0 body)
  209.            | EXCEPTIONdec ebs => app ppEb ebs
  210.            | STRdec strbs => app (ppStrb false) strbs
  211.            | ABSdec strbs => app (ppStrb true) strbs
  212.            | FCTdec fctbs => app ppFctb fctbs
  213.            | SIGdec sigvars => app ppSigb sigvars
  214.            | FSIGdec sigvars => app ppFsigb sigvars
  215.            | LOCALdec(decIn,decOut) => ppDec0 decOut
  216.            | SEQdec decs => app ppDec0 decs
  217.            | FIXdec fixd => ppFixity fixd
  218.            | OVLDdec _ => (add_string ppstrm "overload"; add_newline ppstrm)
  219.            | OPENdec strvs => ppOpen strvs
  220.            | MARKdec(dec,a,b) => ppDec0 dec
  221.  
  222.      in begin_block ppstrm CONSISTENT 0;
  223.     ppDec0 dec;
  224.     end_block ppstrm;
  225.     flush_ppstream ppstrm
  226.     end
  227.  
  228. end (* structure PPDec *)
  229.